home *** CD-ROM | disk | FTP | other *** search
/ Libris Britannia 4 / science library(b).zip / science library(b) / MEDICAL / H121A.ZIP / FILES6.EXE / lha / MEASURE.PAS < prev    next >
Pascal/Delphi Source File  |  1991-07-15  |  27KB  |  688 lines
  1. (*$N+,E+,V-*)
  2. unit measure;
  3.  
  4. interface
  5.  
  6. uses Crt, Dos, EntFace;
  7.  
  8. type
  9.   String1 = string[1];
  10.   String2 = string[2];
  11.   String3 = string[3];
  12.   String4 = string[4];
  13.   Array14B = array[1..14,1..3,1..5,1..4] of real;
  14.  
  15. const
  16.   Coef : Array14B =
  17.  
  18. (((( 0.461824E+02, 0.401257E+01,-0.255449E+00, 0.789966E-02),
  19.    ( 0.673630E+02, 0.133410E+01,-0.421583E-01, 0.101581E-02),
  20.    ( 0.813173E+02, 0.755023E+00, 0.355289E-02,-0.590137E-03),
  21.    ( 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00),
  22.    ( 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00)),
  23.   (( 0.504849E+02, 0.438155E+01,-0.312088E+00, 0.105514E-01),
  24.    ( 0.723318E+02, 0.132797E+01,-0.271990E-01, 0.448522E-03),
  25.    ( 0.876453E+02, 0.814752E+00,-0.701552E-02, 0.609604E-04),
  26.    ( 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00),
  27.    ( 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00)),
  28.   (( 0.547862E+02, 0.475220E+01,-0.368845E+00, 0.132042E-01),
  29.    ( 0.773055E+02, 0.132163E+01,-0.123304E-01,-0.113662E-03),
  30.    ( 0.939720E+02, 0.874997E+00,-0.174451E-01, 0.693745E-03),
  31.    ( 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00),
  32.    ( 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00))),
  33.  ((( 0.457829E+02, 0.367323E+01,-0.237212E+00, 0.779334E-02),
  34.    ( 0.653091E+02, 0.129719E+01,-0.267922E-01, 0.466010E-03),
  35.    ( 0.803115E+02, 0.807980E+00,-0.582173E-02,-0.184636E-03),
  36.    ( 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00),
  37.    ( 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00)),
  38.   (( 0.498644E+02, 0.393746E+01,-0.262999E+00, 0.884779E-02),
  39.    ( 0.704487E+02, 0.135350E+01,-0.241086E-01, 0.339627E-03),
  40.    ( 0.864730E+02, 0.859488E+00,-0.882537E-02, 0.322490E-04),
  41.    ( 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00),
  42.    ( 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00)),
  43.   (( 0.539292E+02, 0.421102E+01,-0.290055E+00, 0.995372E-02),
  44.    ( 0.755903E+02, 0.140880E+01,-0.213041E-01, 0.210055E-03),
  45.    ( 0.926378E+02, 0.911461E+00,-0.118516E-01, 0.242960E-03),
  46.    ( 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00),
  47.    ( 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00))),
  48.  ((( 0.249740E+01, 0.462056E+00, 0.481125E-01,-0.458894E-02),
  49.    ( 0.601058E+01, 0.543800E+00,-0.344885E-01, 0.973626E-03),
  50.    ( 0.925227E+01, 0.136684E+00, 0.562077E-03,-0.236327E-04),
  51.    ( 0.000000E+00, 0.000000E+00, 0.000000E-00, 0.000000E-00),
  52.    ( 0.000000E+00, 0.000000E+00, 0.000000E-00,-0.000000E-00)),
  53.   (( 0.326804E+01, 0.108795E+01,-0.677657E-01, 0.226565E-02),
  54.    ( 0.784554E+01, 0.519450E+00,-0.269840E-01, 0.738014E-03),
  55.    ( 0.114685E+02, 0.190655E+00,-0.415541E-03,-0.133747E-04),
  56.    ( 0.000000E+00, 0.000000E+00,-0.000000E-00, 0.000000E-00),
  57.    ( 0.000000E+00, 0.000000E+00, 0.000000E-00,-0.000000E-00)),
  58.   (( 0.420915E+01, 0.145910E+01,-0.124212E+00, 0.546698E-02),
  59.    ( 0.967299E+01, 0.558989E+00,-0.258067E-01, 0.644479E-03),
  60.    ( 0.137784E+02, 0.218043E+00,-0.260545E-02, 0.106811E-03),
  61.    ( 0.000000E+00, 0.000000E+00,-0.000000E-00, 0.000000E-00),
  62.    ( 0.000000E+00, 0.000000E+00, 0.000000E-00,-0.000000E-00))),
  63.  ((( 0.230235E+01, 0.545715E+00, 0.131161E-01,-0.221402E-02),
  64.    ( 0.557059E+01, 0.463994E+00,-0.267363E-01, 0.773006E-03),
  65.    ( 0.862425E+01, 0.156261E+00, 0.109190E-02,-0.898380E-04),
  66.    ( 0.000000E+00, 0.000000E+00,-0.000000E-00, 0.000000E-00),
  67.    ( 0.000000E+01, 0.000000E+00, 0.000000E-02,-0.000000E-04)),
  68.   (( 0.322751E+01, 0.768817E+00,-0.124130E-01,-0.857452E-03),
  69.    ( 0.720834E+01, 0.527256E+00,-0.278471E-01, 0.752199E-03),
  70.    ( 0.108252E+02, 0.183875E+00,-0.767982E-03, 0.714597E-05),
  71.    ( 0.000000E+00, 0.000000E+00,-0.000000E-00, 0.000000E-00),
  72.    ( 0.000000E+01, 0.000000E+00, 0.000000E-02,-0.000000E-04)),
  73.   (( 0.391945E+01, 0.115426E+01,-0.635733E-01, 0.176581E-02),
  74.    ( 0.893781E+01, 0.582092E+00,-0.317886E-01, 0.930288E-03),
  75.    ( 0.129529E+02, 0.221049E+00, 0.170173E-02,-0.906913E-04),
  76.    ( 0.000000E+00, 0.000000E+00,-0.000000E-00, 0.000000E-00),
  77.    ( 0.000000E+01, 0.000000E+00, 0.000000E-02,-0.000000E-04))),
  78.  ((( 0.250836E+01, 0.681768E-01, 0.126871E-01,-0.259413E-03),
  79.    ( 0.763160E+01, 0.240094E+00,-0.521241E-02, 0.150006E-03),
  80.    ( 0.111393E+02, 0.198252E+00, 0.288790E-02,-0.207356E-04),
  81.    ( 0.000000E+00, 0.000000E+00,-0.000000E-00, 0.000000E-00),
  82.    ( 0.000000E+01, 0.000000E+00, 0.000000E-02,-0.000000E-04)),
  83.   (( 0.314986E+01, 0.148592E+00, 0.947678E-02,-0.205609E-03),
  84.    ( 0.907905E+01, 0.258223E+00,-0.471024E-02, 0.132953E-03),
  85.    ( 0.129763E+02, 0.217885E+00, 0.246924E-02, 0.104389E-03),
  86.    ( 0.000000E+00, 0.000000E+00,-0.000000E-00, 0.000000E-00),
  87.    ( 0.000000E+01, 0.000000E+00, 0.000000E-02,-0.000000E-04)),
  88.   (( 0.409354E+01, 0.188963E+00, 0.873912E-02,-0.193446E-03),
  89.    ( 0.107090E+02, 0.283963E+00,-0.460866E-02, 0.113211E-03),
  90.    ( 0.149874E+02, 0.228093E+00, 0.150476E-02, 0.133490E-03),
  91.    ( 0.000000E+00, 0.000000E+00,-0.000000E-00, 0.000000E-00),
  92.    ( 0.000000E+01, 0.000000E+00, 0.000000E-02,-0.000000E-04))),
  93.  ((( 0.260988E+01, 0.630037E-01, 0.115431E-01,-0.231559E-03),
  94.    ( 0.734790E+01, 0.226503E+00,-0.443447E-02, 0.137357E-03),
  95.    ( 0.107892E+02, 0.200373E+00, 0.298280E-02, 0.891100E-04),
  96.    ( 0.000000E+00, 0.000000E+00,-0.000000E-00, 0.000000E-00),
  97.    ( 0.000000E+01, 0.000000E+00, 0.000000E-02,-0.000000E-04)),
  98.   (( 0.329545E+01, 0.103651E+00, 0.119637E-01,-0.255793E-03),
  99.    ( 0.889598E+01, 0.248036E+00,-0.568606E-02, 0.181276E-03),
  100.    ( 0.125756E+02, 0.219539E+00, 0.410286E-02,-0.204386E-04),
  101.    ( 0.000000E+00, 0.000000E+00,-0.000000E-00, 0.000000E-00),
  102.    ( 0.000000E+01, 0.000000E+00, 0.000000E-02,-0.000000E-04)),
  103.   (( 0.393902E+01, 0.201926E+00, 0.746380E-02,-0.178154E-03),
  104.    ( 0.103641E+02, 0.262530E+00,-0.482882E-02, 0.154783E-03),
  105.    ( 0.144278E+02, 0.239142E+00, 0.352948E-02, 0.139341E-03),
  106.    ( 0.000000E+00, 0.000000E+00,-0.000000E-00, 0.000000E-00),
  107.    ( 0.000000E+01, 0.000000E+00, 0.000000E-02,-0.000000E-04))),
  108.  ((( 0.322108E+02, 0.258812E+01,-0.249611E+00, 0.111355E-01),
  109.    ( 0.411588E+02, 0.795414E+00,-0.491726E-01, 0.131269E-02),
  110.    ( 0.458912E+02, 0.182354E+00,-0.191581E-02,-0.463902E-04),
  111.    ( 0.000000E+00, 0.000000E+00,-0.000000E-00, 0.000000E-00),
  112.    ( 0.000000E+01, 0.000000E+00, 0.000000E-02,-0.000000E-04)),
  113.   (( 0.348510E+02, 0.253355E+01,-0.235109E+00, 0.101480E-01),
  114.    ( 0.437804E+02, 0.808235E+00,-0.524443E-01, 0.140200E-02),
  115.    ( 0.483499E+02, 0.155234E+00,-0.197246E-02,-0.549570E-05),
  116.    ( 0.000000E+00, 0.000000E+00,-0.000000E-00, 0.000000E-00),
  117.    ( 0.000000E+01, 0.000000E+00, 0.000000E-02,-0.000000E-04)),
  118.   (( 0.373458E+02, 0.284554E+01,-0.312001E+00, 0.150148E-01),
  119.    ( 0.464302E+02, 0.723126E+00,-0.417343E-01, 0.106348E-02),
  120.    ( 0.509357E+02, 0.180925E+00,-0.344910E-02, 0.218012E-04),
  121.    ( 0.000000E+00, 0.000000E+00,-0.000000E-00, 0.000000E-00),
  122.    ( 0.000000E+01, 0.000000E+00, 0.000000E-02,-0.000000E-04))),
  123.  ((( 0.320688E+02, 0.210232E+01,-0.165974E+00, 0.640051E-02),
  124.    ( 0.400902E+02, 0.801885E+00,-0.507646E-01, 0.138010E-02),
  125.    ( 0.447875E+02, 0.179737E+00,-0.108106E-02,-0.652464E-04),
  126.    ( 0.000000E+00, 0.000000E+00,-0.000000E-00, 0.000000E-00),
  127.    ( 0.000000E+01, 0.000000E+00, 0.000000E-02,-0.000000E-04)),
  128.   (( 0.342817E+02, 0.231444E+01,-0.217205E+00, 0.966608E-02),
  129.    ( 0.424368E+02, 0.751914E+00,-0.432157E-01, 0.108307E-02),
  130.    ( 0.471083E+02, 0.182624E+00,-0.422515E-02, 0.400879E-04),
  131.    ( 0.000000E+00, 0.000000E+00,-0.000000E-00, 0.000000E-00),
  132.    ( 0.000000E+01, 0.000000E+00, 0.000000E-02,-0.000000E-04)),
  133.   (( 0.359806E+02, 0.283176E+01,-0.317336E+00, 0.154859E-01),
  134.    ( 0.448920E+02, 0.696214E+00,-0.385893E-01, 0.942081E-03),
  135.    ( 0.493177E+02, 0.177050E+00,-0.467440E-02, 0.903841E-04),
  136.    ( 0.000000E+00, 0.000000E+00,-0.000000E-00, 0.000000E-00),
  137.    ( 0.000000E+01, 0.000000E+00, 0.000000E-02,-0.000000E-04))),
  138.  ((( 0.796017E+02, 0.725005E+00,-0.394565E-02, 0.149043E-04),
  139.    ( 0.133056E+03, 0.406485E+00, 0.115162E-02, 0.272229E-04),
  140.    ( 0.147022E+03, 0.549084E+00, 0.360168E-02,-0.162614E-03),
  141.    ( 0.163870E+03, 0.176161E+00,-0.139606E-01, 0.257402E-03),
  142.    ( 0.000000E+01, 0.000000E+00, 0.000000E-02,-0.000000E-04)),
  143.   (( 0.855931E+02, 0.837795E+00,-0.533792E-02, 0.233837E-04),
  144.    ( 0.146374E+03, 0.532432E+00, 0.265930E-02,-0.599481E-04),
  145.    ( 0.163122E+03, 0.530131E+00,-0.273603E-02,-0.522667E-04),
  146.    ( 0.176222E+03, 0.129924E+00,-0.838083E-02, 0.143430E-03),
  147.    ( 0.000000E+01, 0.000000E+00, 0.000000E-02,-0.000000E-04)),
  148.   (( 0.915767E+02, 0.950895E+00,-0.673349E-02, 0.318732E-04),
  149.    ( 0.159692E+03, 0.658332E+00, 0.416714E-02,-0.147054E-03),
  150.    ( 0.179222E+03, 0.511316E+00,-0.906767E-02, 0.577848E-04),
  151.    ( 0.188574E+03, 0.831110E-01,-0.282691E-02, 0.382714E-04),
  152.    ( 0.000000E+01, 0.000000E+00, 0.000000E-02,-0.000000E-04))),
  153.  ((( 0.784609E+02, 0.769969E+00,-0.579066E-02, 0.299200E-04),
  154.    ( 0.100071E+03, 0.469370E+00,-0.255930E-02, 0.298134E-04),
  155.    ( 0.131726E+03, 0.564490E+00, 0.388040E-02,-0.211730E-03),
  156.    ( 0.144582E+03, 0.384879E+00,-0.113642E-01, 0.132304E-03),
  157.    ( 0.149882E+03, 0.810578E-01, 0.292469E-02,-0.738429E-04)),
  158.   (( 0.844872E+02, 0.877385E+00,-0.854191E-02, 0.726632E-04),
  159.    ( 0.105083E+03, 0.561061E+00,-0.200222E-02, 0.171075E-04),
  160.    ( 0.144783E+03, 0.560961E+00, 0.200094E-02,-0.164240E-03),
  161.    ( 0.157128E+03, 0.373200E+00,-0.982432E-02, 0.982153E-04),
  162.    ( 0.162413E+03, 0.477105E-01, 0.782933E-03,-0.217935E-04)),
  163.   (( 0.905784E+02, 0.973526E+00,-0.108372E-01, 0.109954E-03),
  164.    ( 0.112999E+03, 0.620169E+00,-0.941330E-03, 0.461746E-05),
  165.    ( 0.157837E+03, 0.557600E+00, 0.139156E-03,-0.117406E-03),
  166.    ( 0.169676E+03, 0.361401E+00,-0.831408E-02, 0.648912E-04),
  167.    ( 0.174939E+03, 0.150850E-01,-0.130583E-02, 0.268575E-04))),
  168.  ((( 0.102271E+02, 0.110605E+00, 0.502728E-03,-0.356088E-05),
  169.    ( 0.194677E+02, 0.127619E+00,-0.266421E-03, 0.234381E-04),
  170.    ( 0.312284E+02, 0.348780E+00, 0.395244E-02,-0.674519E-04),
  171.    ( 0.496166E+02, 0.261986E+00,-0.576064E-02, 0.333672E-04),
  172.    ( 0.000000E+01, 0.000000E+00, 0.000000E-02,-0.000000E-04)),
  173.   (( 0.123424E+02, 0.202445E+00,-0.116412E-02, 0.118225E-04),
  174.    ( 0.252964E+02, 0.218676E+00, 0.138954E-02, 0.709375E-05),
  175.    ( 0.449515E+02, 0.462032E+00, 0.266641E-02,-0.629917E-04),
  176.    ( 0.663061E+02, 0.282610E+00,-0.640439E-02, 0.619515E-04),
  177.    ( 0.000000E+01, 0.000000E+00, 0.000000E-02,-0.000000E-04)),
  178.   (( 0.154874E+02, 0.219986E+00,-0.841307E-03, 0.189821E-04),
  179.    ( 0.340501E+02, 0.394048E+00, 0.325883E-02,-0.164077E-04),
  180.    ( 0.658807E+02, 0.607904E+00, 0.305441E-03,-0.377818E-04),
  181.    ( 0.915854E+02, 0.376078E+00,-0.513514E-02,-0.177567E-04),
  182.    ( 0.000000E+01, 0.000000E+00, 0.000000E-02,-0.000000E-04))),
  183.  ((( 0.958878E+01, 0.162168E+00,-0.158785E-02, 0.141728E-04),
  184.    ( 0.166639E+02, 0.124691E+00, 0.963245E-03, 0.307446E-05),
  185.    ( 0.282771E+02, 0.273485E+00, 0.151665E-02,-0.370240E-04),
  186.    ( 0.408042E+02, 0.163173E+00,-0.381481E-02, 0.315956E-04),
  187.    ( 0.000000E+01, 0.000000E+00, 0.000000E-02,-0.000000E-04)),
  188.   (( 0.117963E+02, 0.219662E+00,-0.262788E-02, 0.292835E-04),
  189.    ( 0.218409E+02, 0.220578E+00, 0.264314E-02,-0.141618E-04),
  190.    ( 0.415319E+02, 0.384808E+00, 0.940228E-04,-0.391686E-04),
  191.    ( 0.558876E+02, 0.123101E+00,-0.554625E-02, 0.702252E-04),
  192.    ( 0.000000E+01, 0.000000E+00, 0.000000E-02,-0.000000E-04)),
  193.   (( 0.144385E+02, 0.322835E+00,-0.438366E-02, 0.540144E-04),
  194.    ( 0.296945E+02, 0.380152E+00, 0.533894E-02,-0.449181E-04),
  195.    ( 0.620215E+02, 0.535709E+00,-0.274632E-02,-0.206170E-04),
  196.    ( 0.791280E+02, 0.129558E+00,-0.571516E-02, 0.648512E-04),
  197.    ( 0.000000E+01, 0.000000E+00, 0.000000E-02,-0.000000E-04))),
  198.  ((( 0.288221E+01, 0.311757E+00,-0.339993E-02, 0.332712E-04),
  199.    ( 0.907104E+01, 0.204144E+00,-0.904587E-03, 0.465496E-04),
  200.    ( 0.171038E+02, 0.311893E+00, 0.398312E-02,-0.276662E-04),
  201.    ( 0.000000E+01, 0.000000E+00, 0.000000E-02,-0.000000E-04),
  202.    ( 0.000000E+01, 0.000000E+00, 0.000000E-02,-0.000000E-04)),
  203.   (( 0.431260E+01, 0.371447E+00,-0.633119E-02, 0.877037E-04),
  204.    ( 0.110122E+02, 0.219333E+00, 0.246595E-03, 0.313171E-04),
  205.    ( 0.203336E+02, 0.351685E+00, 0.353489E-02, 0.104383E-03),
  206.    ( 0.000000E+01, 0.000000E+00, 0.000000E-02,-0.000000E-04),
  207.    ( 0.000000E+01, 0.000000E+00, 0.000000E-02,-0.000000E-04)),
  208.   (( 0.658687E+01, 0.352637E+00,-0.345830E-02, 0.293354E-04),
  209.    ( 0.136997E+02, 0.234726E+00,-0.125814E-02, 0.889698E-04),
  210.    ( 0.241885E+02, 0.473620E+00, 0.808368E-02, 0.103298E-03),
  211.    ( 0.000000E+01, 0.000000E+00, 0.000000E-02,-0.000000E-04),
  212.    ( 0.000000E+01, 0.000000E+00, 0.000000E-02,-0.000000E-04))),
  213.  ((( 0.303896E+01, 0.276098E+00,-0.226928E-02, 0.201277E-04),
  214.    ( 0.982301E+01, 0.194286E+00,-0.457785E-03, 0.537775E-04),
  215.    ( 0.147037E+02, 0.258573E+00, 0.325286E-02, 0.168530E-04),
  216.    ( 0.000000E+01, 0.000000E+00, 0.000000E-02,-0.000000E-04),
  217.    ( 0.000000E+01, 0.000000E+00, 0.000000E-02,-0.000000E-04)),
  218.   (( 0.430208E+01, 0.364667E+00,-0.629446E-02, 0.835936E-04),
  219.    ( 0.118341E+02, 0.212702E+00, 0.122896E-02, 0.201561E-04),
  220.    ( 0.176216E+02, 0.301222E+00, 0.261973E-02, 0.121334E-03),
  221.    ( 0.000000E+01, 0.000000E+00, 0.000000E-02,-0.000000E-04),
  222.    ( 0.000000E+01, 0.000000E+00, 0.000000E-02,-0.000000E-04)),
  223.   (( 0.658206E+01, 0.363970E+00,-0.609859E-02, 0.885250E-04),
  224.    ( 0.144026E+02, 0.237072E+00, 0.186866E-02, 0.269321E-04),
  225.    ( 0.211715E+02, 0.365772E+00, 0.372698E-02, 0.332188E-03),
  226.    ( 0.000000E+01, 0.000000E+00, 0.000000E-02,-0.000000E-04),
  227.    ( 0.000000E+01, 0.000000E+00, 0.000000E-02,-0.000000E-04))));
  228.  
  229.   Fudge = 1E-9;
  230.  
  231. var
  232.   Knot : array[1..14,1..5] of real;
  233.  
  234. Procedure  JCS2ZS (Age : real; ISex : Byte;
  235.                    Ht, Wt : Real;
  236.                    var HAC, WHC, WAC, HAZ, WHZ, WAZ, HAPM, WHPM, WAPM : Real;
  237.                    var Flag : Byte);
  238.  
  239. Function MyDoScores (Header   : FieldPtr;
  240.                      Current  : FieldPtr;
  241.                      Data     : Integer) : Integer;
  242.  
  243.  
  244. implementation
  245.  
  246.  
  247. {----------------------------------------------------------------------------}
  248. {                                                                            }
  249. {----------------------------------------------------------------------------}
  250. procedure InitKnot;
  251.  
  252. begin
  253.   Knot[1,1]  :=   0.0; Knot[2,1]  :=   0.0; Knot[3,1]  :=   0.0;
  254.   Knot[4,1]  :=   0.0; Knot[5,1]  :=  49.0; Knot[6,1]  :=  49.0;
  255.   Knot[7,1]  :=   0.0; Knot[8,1]  :=   0.0; Knot[9,1]  :=  24.0;
  256.   Knot[10,1] :=  24.0; Knot[11,1] :=  24.0; Knot[12,1] :=  24.0;
  257.   Knot[13,1] :=  55.0; Knot[14,1] :=  55.0;
  258.  
  259.   Knot[1,2]  :=   9.0; Knot[2,2]  :=   9.0; Knot[3,2]  :=   6.0;
  260.   Knot[4,2]  :=   6.0; Knot[5,2]  :=  72.0; Knot[6,2]  :=  72.0;
  261.   Knot[7,2]  :=   6.0; Knot[8,2]  :=   6.0; Knot[9,2]  := 138.0;
  262.   Knot[10,2] :=  54.0; Knot[11,2] :=  96.0; Knot[12,2] :=  84.0;
  263.   Knot[13,2] :=  80.0; Knot[14,2] :=  85.0;
  264.  
  265.   Knot[1,3]  :=  24.0; Knot[2,3]  :=  24.0; Knot[3,3]  :=  18.0;
  266.   Knot[4,3]  :=  18.0; Knot[5,3]  :=  90.0; Knot[6,3]  :=  90.0;
  267.   Knot[7,3]  :=  18.0; Knot[8,3]  :=  18.0; Knot[9,3]  := 168.0;
  268.   Knot[10,3] := 132.0; Knot[11,3] := 156.0; Knot[12,3] := 144.0;
  269.   Knot[13,3] := 115.0; Knot[14,3] := 108.0;
  270.  
  271.   Knot[1,4]  :=   0.0; Knot[2,4]  :=   0.0; Knot[3,4]  :=   0.0;
  272.   Knot[4,4]  :=   0.0; Knot[5,4]  :=   0.0; Knot[6,4]  :=   0.0;
  273.   Knot[7,4]  :=   0.0; Knot[8,4]  :=   0.0; Knot[9,4]  := 204.0;
  274.   Knot[10,4] := 156.0; Knot[11,4] := 204.0; Knot[12,4] := 192.0;
  275.   Knot[13,4] :=   0.0; Knot[14,4] :=   0.0;
  276.  
  277.   Knot[1,5]  :=   0.0; Knot[2,5]  :=   0.0; Knot[3,5]  :=   0.0;
  278.   Knot[4,5]  :=   0.0; Knot[5,5]  :=   0.0; Knot[6,5]  :=   0.0;
  279.   Knot[7,5]  :=   0.0; Knot[8,5]  :=   0.0; Knot[9,5]  :=   0.0;
  280.   Knot[10,5] := 192.0; Knot[11,5] :=   0.0; Knot[12,5] :=   0.0;
  281.   Knot[13,5] :=   0.0; Knot[14,5] :=   0.0;
  282. end;
  283.  
  284.  
  285. {----------------------------------------------------------------------------}
  286. {                                                                            }
  287. {----------------------------------------------------------------------------}
  288. procedure Eval(X : real; I,J : integer; var V : real; LL,UL : real);
  289.  
  290. label L10, L20, L30, L40, L50;
  291. const
  292.   KD   : array[1..14] of integer = (3,3,3,3,3,3,3,3,4,5,4,4,3,3);
  293.  
  294. var
  295.   K    : byte;
  296.   A    : real;
  297.  
  298.  
  299. begin
  300.   if J = 1 then Knot[10,2] := 60.0;
  301.   if J <> 1 then Knot[10,2] := 54.0;
  302.   if ((X < LL) or (X > UL)) and (LL <> UL) then GOTO L50;
  303.   K := KD[I];
  304. L10:
  305.   A := X - Knot[I,K];
  306.   if A < 0 then GOTO L20
  307.   else          GOTO L40;
  308. L20:
  309.   K := K - 1;
  310.   if K > 0 then GOTO L10
  311.   else          GOTO L30;
  312. L30:
  313.   K := 1;
  314. L40:
  315.   V := Coef[I,J,K,1] + A * (Coef[I,J,K,2] + A * (Coef[I,J,K,3] +
  316.        A * Coef[I,J,K,4]));
  317.   Exit;
  318. L50:
  319.   V := 999.9;
  320. end;
  321.  
  322. {----------------------------------------------------------------------------}
  323. {                                                                            }
  324. {----------------------------------------------------------------------------}
  325. procedure ZScr (I : integer; X, Ms : real; var Zsc, LL, UL : real);
  326.  
  327. label L20, L30, L40;
  328.  
  329. var
  330.   J    : byte;
  331.   V,
  332.   XX,
  333.   AZsc : real;
  334.   SD   : array[1..2] of real;
  335.   Y    : array[1..3] of real;
  336.  
  337. begin
  338.   if ((X < LL) or (X > UL)) and (LL <> UL) then GOTO L40;
  339.   for J := 1 to 3 do
  340.   begin
  341.     Eval(X,I,J,V,LL,UL);
  342.     Y[J] := V
  343.   end;
  344.   SD[1] := Abs((Y[2] - Y[1]) / 1.8807936);
  345.   SD[2] := Abs((Y[2] - Y[3]) / 1.8807936);
  346.   if (LL <> UL) then GOTO L20;
  347.   ZSc := Y[2];
  348.   LL  := SD[1];
  349.   UL  := SD[2];
  350.   Exit;
  351. L20:
  352.   if (Ms >= Y[2]) then GOTO L30;
  353.   ZSc := (Ms - Y[2]) / SD[1];
  354.   if ZSc >= -9.98 then Exit;
  355.   ZSc := -9.98;
  356.   Exit;
  357. L30:
  358.   ZSc := (Ms - Y[2]) / SD[2];
  359.   if ZSc <= 9.98 then Exit;
  360.   ZSc := 9.98;
  361.   Exit;
  362. L40:
  363.   ZSc := 9.99
  364. end;
  365.  
  366. {--------------------------------------------------------------------}
  367. { The following function raises X to the power Y                     }
  368. {--------------------------------------------------------------------}
  369.  
  370. function XToPowerY (X, Y : real) : real;
  371.  
  372. begin
  373.   XToPowerY := Exp(Y * Ln(X))
  374. end;
  375.  
  376. {--------------------------------------------------------------------}
  377. {                                                                    }
  378. {--------------------------------------------------------------------}
  379. function ZPct (Z : real) : real;
  380.  
  381. const
  382.   B : array[1..5] of real = (0.31938153, -0.356563782, 1.781477937,
  383.                             -1.821255978, 1.330274429);
  384. var
  385.   TempZPct,
  386.   DZp,
  387.   DZ,
  388.   R,
  389.   T,
  390.   Fx  : real;
  391.   I,
  392.   Neg : integer;
  393.  
  394. begin
  395.   DZp := 0.0;
  396.   R   := 0.2316419;
  397.   if Z > 9.985 then ZPct := 99.9
  398.   else
  399.   begin
  400.     Neg := 0;
  401.     DZp := 0.0;
  402.     if Z < 0 then Neg := 1;
  403.     DZ := Abs(Z);
  404.     T  := 1.0 / (1.0 + DZ * R);
  405.     for I := 1 to 5 do
  406.       DZp := B[I] * XToPowerY(T, I) + DZp;
  407.     Fx := 1.0 / Sqrt(2 * Pi) * Exp(-0.5 * Sqr(DZ));
  408.     DZp := DZp * Fx;
  409.     TempZPct := DZp * 100.0;
  410.     if Neg <> 1 then TempZPct := 100.0 - TempZPct;
  411.     if (TempZPct > 99.8) then TempZPct := 99.8;
  412.     ZPct := TempZPct
  413.   end
  414. end;
  415.  
  416. {----------------------------------------------------------------------------}
  417. {                                                                            }
  418. {----------------------------------------------------------------------------}
  419. procedure  JCS2ZS (Age : real; ISex : Byte;
  420.                    Ht, Wt : Real;
  421.                    var HAC, WHC, WAC, HAZ, WHZ, WAZ, HAPM, WHPM, WAPM : Real;
  422.                    var Flag : Byte);
  423.  
  424. label L10, L20, L40, L50, L60, L70, L80, L90, L100, L110, L120, L130, L140,
  425.       L150, L160, L170;
  426.  
  427. const
  428.   ULmt : array[1..16] of real = (36.0,   36.0,   36.0,   36.0,
  429.                                 103.0,  101.0,   36.0,   36.0,
  430.                                 215.99, 215.99, 215.99, 215.99,
  431.                                 145.0,  137.0,  138.0,  120.0);
  432.   LLmt : array[1..16] of real = (0.0,  0.0,  0.0,  0.0,
  433.                                 49.0, 49.0,  0.0,  0.0,
  434.                                 24.0, 24.0, 24.0, 24.0,
  435.                                 55.0, 55.0, 24.0, 24.0);
  436.  
  437. var
  438.   ErrCode,
  439.   I       : integer;
  440.   X,
  441.   MS,
  442.   PMed,
  443.   Cntl,
  444.   UL,
  445.   LL,
  446.   V,
  447.   WZ,
  448.   ZSc     : real;
  449.  
  450.   Function StrToByte (S : String) : Integer;
  451.     Var
  452.       I, J : Integer;
  453.     Begin
  454.       Val (S, I, J);
  455.       If J <> 0
  456.       Then
  457.         I := 0;
  458.       StrToByte := I
  459.     End (*StrToByte*);
  460.  
  461.   Function StrToReal (S : String) : Real;
  462.     Var
  463.       I : Integer;
  464.       R : Real;
  465.     Begin
  466.       Val (S, R, I);
  467.       If I <> 0
  468.       Then
  469.         R := 0;
  470.       StrToReal := R
  471.     End (*StrToReal*);
  472.  
  473.   Function Form (S : String; Num : Real) : String;
  474.  
  475.     Begin
  476.       Str (Num: Length (S): 0, S);
  477.       Form := S
  478.     End (*Form*);
  479.  
  480.  
  481. begin
  482.  
  483. {
  484.   Val(AgeMos + Age100s, Age, ErrCode);    (*******************************)
  485.   Age := Age / 100;                       (*  Note : conversions could   *)
  486.   Val(StSex, ISex, ErrCode);              (*  be done this way and avoid *)
  487.   Val(StHt, Ht, ErrCode);                 (*  using the Math unit.       *)
  488.   Ht := Ht / 10;                          (*  This could pay off if      *)
  489.   Val(StWt, Wt,ErrCode);                  (*  all other pieces of the    *)
  490.   Wt := Wt / 10;                          (*  puzzle can avoid Math also *)
  491. }                                         (*******************************)
  492.  
  493.  
  494.   if (ISex <> 1) and (ISex <> 2) then GOTO L150;
  495.   If (Age >= 0.0) and (Age <= 215.99) then GOTO L40;
  496.   I := ISex + 4;
  497.   LL := LLmt[I];
  498.   UL := ULmt[I];
  499.   if (Ht >= 85.0) then GOTO L10;
  500.   if (Ht < LL) then GOTO L150;
  501.   If (Wt > 999.0) then GOTO L150;
  502.   ZScr(I,Ht,Wt,WHZ,LL,UL);
  503.   Eval(Ht,I,2,WZ,LL,UL);
  504.   GOTO L20;
  505. L10:
  506.   I := I + 8;
  507.   LL := LLmt[I];
  508.   UL := ULmt[I];
  509.   if (Ht > UL) then GOTO L150;
  510.   if (Wt > 999.0) then GOTO L150;
  511.   ZScr(I,Ht,Wt,WHZ,LL,UL);
  512.   Eval(Ht,I,2,WZ,LL,UL);
  513. L20:
  514.   WHPM := Wt / Wz * 100.0;
  515.   WHC  := ZPct(WHZ);
  516.   GOTO L160;
  517. L40:
  518.   if (Age < 24.0) then GOTO L50;
  519.   I := ISex + 8;
  520.   GOTO L60;
  521. L50:
  522.   I := ISex;
  523. L60:
  524.   MS := Ht;
  525.   X  := Age;
  526. L70:
  527.   UL := ULmt[I];
  528.   LL := LLmt[I];
  529.   if (X < LL) or (X > UL) then GOTO L80;
  530.   if (MS > 999.0) or (MS <= 0.01) then GOTO L80;
  531.   Eval(X,I,2,V,LL,UL);
  532.   ZScr(I,X,MS,ZSc,LL,UL);
  533.   PMed := (MS / V) * 100.0;
  534.   GOTO L90;
  535. L80:
  536.   PMed := 999.9;
  537.   ZSc  :=   9.99;
  538. L90:
  539.   case I of
  540.     1,2, 9,10 : GOTO L100;
  541.     3,4,11,12 : GOTO L110;
  542.     5,6,13,14 : GOTO L120;
  543.     7,8,15,16 : GOTO L170
  544.   end;
  545. L100:
  546.   HAPM := PMed;
  547.   HAZ  := ZSc;
  548.   HAC  := ZPct(ZSc);
  549.   Ms   := Wt;
  550.   GOTO L140;
  551. L110:
  552.   WAPM := PMed;
  553.   WAZ  := ZSc;
  554.   WAC  := ZPct(Zsc);
  555.   X    := Ht;
  556.   GOTO L140;
  557. L120:
  558.   X  := Age;
  559.   UL := ULmt[I + 2];
  560.   LL := LLmt[I + 2];
  561.   if (X < LL) or (X > UL) then GOTO L130;
  562.   if (Wt > 999.0) then GOTO L130;
  563.   WHPM := PMed;
  564.   WHZ := ZSc;
  565.   WHC := ZPct(ZSc);
  566.   GOTO L170;
  567. L130:
  568.   WHC  :=  99.9;
  569.   WHPM := 999.9;
  570.   WHZ  :=   9.99;
  571.   GOTO L170;
  572. L140:
  573.   I := I + 2;
  574.   GOTO L70;
  575. L150:
  576.   WHC  :=  99.9;
  577.   WHPM := 999.9;
  578.   WHZ  :=   9.99;
  579. L160:
  580.   HAC  :=  99.9;
  581.   HAPM := 999.9;
  582.   HAZ  :=   9.99;
  583.   WAC  :=  99.9;
  584.   WAPM := 999.9;
  585.   WAZ  :=   9.99;
  586. L170:
  587.  
  588. (**************************************************************************)
  589. (* The following variable Flag is an addition requested by Kevin Sullivan *)
  590. (* and was added on 1/10/90 by Ray Smith.  I think we probably need to    *)
  591. (* check on the branching that could lead to execution of these           *)
  592. (* statements when preceeding logic leads to the 999 type values.         *)
  593. (**************************************************************************)
  594.   Flag := 0;
  595.   if (HAZ < -6) or (HAZ > 6) then Flag :=1;
  596.   if (WHZ < -4) or (WHZ > 6) then Inc(Flag,2);
  597.   if (WAZ < -6) or (WAZ > 6) then Inc(Flag,4);
  598.   if ((HAZ > 3.09) and (WHZ < -3.09)) or
  599.      ((HAZ < -3.09) and (WHZ > 3.09)) then
  600.      if (Flag >= 0) and (Flag < 4) then
  601.         Flag := 3
  602.      else
  603.         Flag := 7;
  604. end;
  605.  
  606. (*$F+*)
  607.   Function MyDoScores (Header   : FieldPtr;
  608.                        Current  : FieldPtr;
  609.                        Data     : Integer) : Integer;
  610.  
  611.     Var
  612.       AgePtr, SexPtr, WtPtr, HtPtr : FieldPtr;
  613.       ISex, Flag : Byte;
  614.       HAC, WHC, WAC, HAZ, WHZ, WAZ, HAPM, WHPM, WAPM : Real;
  615.       Ch : Char;
  616.       S : String[80];
  617.  
  618.       Procedure FieldNotFound;
  619.         Begin
  620.           GotoXY (1, 23);
  621.           Write ('Something wrong with interprogram communication.');
  622.           MyDoScores := 1;
  623.           Ch := ReadKey
  624.         End (*Else*);
  625.  
  626.     Begin {MyDoScores}
  627.       MyDoScores := 0;
  628.       SwapVectors;
  629.       AgePtr := FindField (Header, 'AGE');
  630.       SexPtr := FindField (Header, 'SEX');
  631.       WtPtr := FindField (Header, 'WEIGHT');
  632.       HtPtr := FindField (Header, 'HEIGHT');
  633.       If Ageptr = nil then
  634.         begin
  635.           GotoXY (1,22);
  636.           write ('AGEPTR is nil');
  637.         end;
  638.       TextAttr := 31;
  639.       If (AgePtr <> NIL) And (SexPtr <> NIL) And
  640.          (WtPtr <> NIL) And (HtPtr <> NIL)
  641.       Then
  642.         Begin
  643.         {Get the contents of four fields in the questionnaire and send
  644.         to the JCS2ZS procedure to perform calculations.  Could have
  645.         used GetString and GetNumber here to make the code clearer, but
  646.         this illustrates how to access the FieldList records
  647.         in ENTER directly.}
  648.           If SexPtr ^.FieldEntry [1] in ['F', 'f', '2']
  649.           Then
  650.              ISex := 2
  651.           Else If SexPtr^.FieldEntry[1] in ['M', 'm', '1']
  652.           Then
  653.             ISex := 1;
  654.           {Send out the 4 values and get 10 back}
  655.           JCS2ZS (AgePtr ^.FieldReal, ISex,
  656.                   HtPtr ^.FieldReal, WtPtr ^.FieldReal,
  657.                   HAC, WHC, WAC, HAZ, WHZ, WAZ, HAPM, WHPM, WAPM, Flag);
  658.  
  659.           { Write Height for Age information to fields in questionnaire}
  660.           PutNumber (Header,'HAP',HAC);
  661.           PutNumber (Header,'HAZ',HAZ);
  662.           PutNumber (header,'HAM',HAPM);
  663.  
  664.           { Write Weight for Age information }
  665.           PutNumber (Header,'WAP',WAC);
  666.           PutNumber (Header,'WAZ',WAZ);
  667.           PutNumber (Header,'WAM',WAPM);
  668.  
  669.           { Write Weight for Height information }
  670.           PutNumber (Header,'WHP',WHC);
  671.           PutNumber (Header,'WHZ',WHZ);
  672.           PutNumber (Header,'WHM',WHPM);
  673.  
  674.           { Write Flag information }
  675.           PutNumber (Header,'FLAG',Flag);
  676.         End (*If*)
  677.       Else  FieldNotFound;
  678.       SwapVectors
  679.     End (*MyDoScores*);
  680. (*$F-*)
  681.  
  682. (***************)
  683. (*  Main Body  *)
  684. (***************)
  685. begin
  686.   InitKnot;
  687. end.
  688.